home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PAS_0693 / GRAPHPRC.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-30  |  5KB  |  145 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 603 of 643
  3. From : Sean Palmer                         1:104/123.0          07 Jun 93  13:58
  4. To   : John Linden
  5. Subj : Graphics
  6. ────────────────────────────────────────────────────────────────────────────────
  7. JL>I use a plot command I wrote..
  8.  
  9. JL>1. How can I create an all-around procedure to draw lines . Horizontal and
  10. JL>vertical are simple but what are diagonals?? Some code please...and
  11. circles?
  12.  
  13. JL>2. How do you create a good fill procedure to fill a polygon with a color
  14. JL>etc... ??? More code please..
  15.  
  16. There, that's the last time I post any of that stuff.
  17.  
  18. All this is tested.}
  19.  
  20. procedure rect(x,y,x2,y2:integer);var i:word;begin
  21.  hlin(x,pred(x2),y);hlin(succ(x),x2,y2);
  22.  vlin(x,succ(y),y2);vlin(x2,y,pred(y2));
  23.  end;
  24.  
  25. procedure pane(x,y,x2,y2:integer);var i:word;begin
  26.  for i:=y2 downto y do hlin(x,x2,i);
  27.  end;
  28.  
  29. procedure line(x,y,x2,y2:integer);var d,dx,dy,ai,bi,xi,yi:integer;begin
  30.  if(x<x2)then begin xi:=1;dx:=x2-x;end else begin xi:=-1;dx:=x-x2;end;
  31.  if(y<y2)then begin yi:=1;dy:=y2-y;end else begin yi:=-1;dy:=y-y2;end;
  32.  plot(x,y);
  33.  if dx>dy then begin ai:=(dy-dx)*2;bi:=dy*2; d:=bi-dx;
  34.   repeat
  35.    if(d>=0)then begin inc(y,yi);inc(d,ai);end else inc(d,bi);
  36.    inc(x,xi);plot(x,y);
  37.    until(x=x2);
  38.   end
  39.  else begin ai:=(dx-dy)*2;bi:=dx*2; d:=bi-dy;
  40.   repeat
  41.    if(d>=0)then begin inc(x,xi);inc(d,ai);end else inc(d,bi);
  42.    inc(y,yi);plot(x,y);
  43.    until(y=y2);
  44.   end;
  45.  end;
  46.  
  47. procedure oval(xc,yc,a,b:integer);var
  48. x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin  x:=0;y:=b;
  49. aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;  d:=bb-aa*b+aa div 4;
  50. dx:=0;dy:=aa2*b;  plot(xc,yc-y);plot(xc,yc+y);plot(xc-a,yc);plot(xc+a,yc);
  51.  while(dx<dy)do begin
  52.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  53.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  54.   plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
  55.   end;
  56.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  57.  while(y>0)do begin
  58.   if(d<0)then begin inc(x); inc(dx,bb2); inc(d,bb+dx); end;
  59.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  60.   plot(xc+x,yc+y); plot(xc-x,yc+y); plot(xc+x,yc-y); plot(xc-x,yc-y);
  61.   end;
  62.  end;
  63.  
  64. procedure disk(xc,yc,a,b:integer);var
  65. x,y:integer;aa,aa2,bb,bb2,d,dx,dy:longint;begin  x:=0;y:=b;
  66. aa:=longint(a)*a;aa2:=2*aa; bb:=longint(b)*b;bb2:=2*bb;  d:=bb-aa*b+aa div 4;
  67. dx:=0;dy:=aa2*b;  vLin(xc,yc-y,yc+y);
  68.  while(dx<dy)do begin
  69.   if(d>0)then begin dec(y); dec(dy,aa2); dec(d,dy); end;
  70.   inc(x); inc(dx,bb2); inc(d,bb+dx);
  71.   vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
  72.   end;
  73.  inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
  74.  while(y>=0)do begin
  75.   if(d<0)then begin
  76.    inc(x); inc(dx,bb2); inc(d,bb+dx);
  77.    vLin(xc-x,yc-y,yc+y);vLin(xc+x,yc-y,yc+y);
  78.    end;
  79.   dec(y); dec(dy,aa2); inc(d,aa-dy);
  80.   end;
  81.  end;
  82.  
  83. var fillVal:byte;
  84. {This routine only called by fill}
  85. function lineFill(x,y,d,prevXL,prevXR:integer):integer;var
  86. xl,xr,i:integer;label _1,_2,_3;begin  xl:=x;xr:=x;
  87.  repeat dec(xl); until(scrn(xl,y)<>fillVal)or(xl<0); inc(xl);
  88.  repeat inc(xr); until(scrn(xr,y)<>fillVal)or(xr>xMax); dec(xr);
  89.  hLin(xl,xr,y);
  90.  inc(y,d);
  91.  if word(y)<=yMax then
  92.   for x:=xl to xr do
  93.    if(scrn(x,y)=fillVal)then begin
  94.     x:=lineFill(x,y,d,xl,xr);
  95.     if word(x)>xr then goto _1;
  96.     end;
  97. _1:dec(y,d+d); asm neg d;end;
  98.  if word(y)<=yMax then begin
  99.   for x:=xl to prevXL do
  100.    if(scrn(x,y)=fillVal)then begin
  101.     i:=lineFill(x,y,d,xl,xr);
  102.     if word(x)>prevXL then goto _2;
  103.     end;
  104. _2:for x:=prevXR to xr do
  105.    if(scrn(x,y)=fillVal)then begin
  106.     i:=lineFill(x,y,d,xl,xr);
  107.     if word(x)>xr then goto _3;
  108.     end;
  109. _3:end;
  110.  lineFill:=xr;
  111.  end;
  112.  
  113. procedure fill(x,y:integer);begin
  114.  fillVal:=scrn(x,y);if fillVal<>color then lineFill(x,y,1,x,x);
  115.  end;
  116.  
  117.  
  118. const
  119.  tableReadIndex=$3C7;
  120.  tableWriteIndex=$3C8;
  121.  tableDataRegister=$3C9;
  122.  
  123. procedure setColor(color,r,g,b:byte);assembler;asm {set DAC color}
  124.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  125.  mov al,r; out dx,al; mov al,g; out dx,al; mov al,b;out dx,al;
  126.  end; {write index now points to next color}
  127.  
  128. function getColor(color:byte):longint;assembler;asm {get DAC color}
  129.  mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2; cld;
  130.  xor bh,bh; in al,dx; mov bl,al; in al,dx; mov ah,al; in al,dx; mov dx,bx;
  131.  end; {read index now points to next color}
  132.  
  133. procedure setPalette(color:byte;num:word;var rgb);assembler;asm
  134.  mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
  135.  push ds; lds si,rgb; cld;
  136.  mov dx,tableWriteIndex; mov al,color; out dx,al; inc dx;
  137. @L: lodsb; out dx,al; loop @L; pop ds; @X:
  138.  end;
  139.  
  140. procedure getPalette(color:byte;num:word;var rgb);assembler;asm
  141.  mov cx,num; jcxz @X; mov ax,cx; shl cx,1; add cx,ax; {mul by 3}
  142.  les di,rgb; cld;
  143.  mov dx,tableReadIndex; mov al,color; out dx,al; add dx,2;
  144. @L: in al,dx; stosb; loop @L; @X:
  145.  end;